COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	DEFINE NIL='400000, LIST="INTEGER"
C00010 ENDMK
C⊗;
DEFINE NIL='400000, LIST="INTEGER";
DEFINE NILNIL=NIL+1;
DEFINE BEGINLIST=5;
OWN SAFE LIST ARRAY CAD[NIL:NIL+NLIST],
                    EVC[NIL LSH -2:(NIL+NLIST+3) LSH -2],
                    ROOT[0:NROOT];
PRELOAD_WITH '777,'777000,'777000000,'777000000000;
OWN SAFE INTEGER ARRAY EVCMASK[0:3];
PRELOAD_WITH '001,'001000,'001000000,'001000000000;
OWN SAFE INTEGER ARRAY EVCONE[0:3];

SIMPLE LIST PROCEDURE CAR(LIST EL); RETURN(CAD[EL] LSH -18);

SIMPLE LIST PROCEDURE CDR(LIST EL); RETURN(CAD[EL] LAND '777777);

SIMPLE BOOLEAN PROCEDURE NULLP(LIST EL); RETURN(EL=NIL);

SIMPLE BOOLEAN PROCEDURE LISTP(LIST EL); RETURN(EL>NIL);

SIMPLE BOOLEAN PROCEDURE ATOMP(LIST EL); RETURN(EL<NIL);

SIMPLE LIST PROCEDURE RPLACA(LIST EL, VAL);
   BEGIN
   CAD[EL]←(CAD[EL] LAND '777777) LOR (VAL LSH 18);
   RETURN(EL);
   END;

SIMPLE LIST PROCEDURE RPLACD(LIST EL, VAL);
   BEGIN
   CAD[EL]←(CAD[EL] LAND '777777000000) LOR VAL;
   RETURN(EL);
   END;

RECURSIVE PROCEDURE COLLECT(LIST NODE);
   BEGIN
   INTEGER NOS;
   WHILE LISTP(NODE)∧((EVC[NODE LSH -2]←EVC[NODE LSH -2]-EVCONE[NODE LAND '3])
                                             LAND EVCMASK[NODE LAND '3])=0  DO
      BEGIN
      NOS←NODE;
      COLLECT(CAR(NODE));
      NODE←CDR(NOS);
      CAD[NOS]←ROOT[0];
      EVC[NOS ASH -2]←
         EVCONE[NOS LAND '3]+(EVC[NOS ASH -2] LAND LNOT EVCMASK[NOS LAND '3]);
      ROOT[0]←NOS;
      END;
   END;

SIMPLE LIST PROCEDURE CONS(LIST A,B);
   BEGIN
   LIST NODE;
   IF LISTP(A) THEN EVC[A LSH -2]←EVC[A LSH -2]+EVCONE[A LAND '3];
   IF LISTP(B) THEN EVC[B LSH -2]←EVC[B LSH -2]+EVCONE[B LAND '3];
   IF NULLP(ROOT[0]) THEN
      BEGIN
      PRINT("COLLECT ");
      FOR NODE←NIL+BEGINLIST STEP 1 UNTIL NIL+NLIST DO
      IF (EVC[NODE LSH -2] LAND EVCMASK[NODE LAND '3])=0 THEN
	 BEGIN
	 COLLECT(CAR(NODE));
	 COLLECT(CDR(NODE));
	 CAD[NODE]←ROOT[0];
	 EVC[NODE LSH -2]←
            EVCONE[NODE LAND '3]+(EVC[NODE ASH -2] LAND LNOT EVCMASK[NODE LAND '3]);
	 ROOT[0]←NODE;
	 END;
      END;
   IF NULLP(ROOT[0]) THEN
      BEGIN
      OUTSTR("List storage capacity exceeded"&'15&'12);
      call(0,"EXIT");
      END;
   NODE←ROOT[0];
   ROOT[0]←CDR(ROOT[0]);
   CAD[NODE]←(A LSH 18) LOR B;
   EVC[NODE LSH -2]←EVC[NODE LSH -2] LAND LNOT EVCMASK[NODE LAND '3];
   RETURN(NODE);
   END;

SIMPLE PROCEDURE SETQ(REFERENCE INTEGER RT; LIST LS);
   BEGIN
   IF LISTP(LS) THEN EVC[LS LSH -2]←EVC[LS LSH -2]+EVCONE[LS LAND '3];
   COLLECT(RT); RT←LS;
   END;

SIMPLE PROCEDURE DISSET(INTEGER RT);
   IF LISTP(RT) THEN EVC[RT LSH -2]←EVC[RT LSH -2]-EVCONE[RT LAND '3];

SIMPLE PROCEDURE LINIT;
   BEGIN
   LIST I;
   CAD[NIL]←NIL; EVC[NIL LSH -2]←EVCONE[NIL LAND '3]; ROOT[0]←NIL+BEGINLIST;
   FOR I←NIL+BEGINLIST STEP 1 UNTIL NIL+NLIST DO
      BEGIN
      CAD[I]←I+1;
      EVC[I LSH -2]←EVC[I LSH -2] LOR EVCONE[I LAND '3];
      END;
   CAD[NIL+NLIST]←NIL;
   FOR I←1 STEP 1 UNTIL NROOT DO ROOT[I]←NIL;
   CAD[NILNIL]←(NIL LSH 18) LOR NIL;  comment make NIL.NIL;
   EVC[NILNIL LSH -2]←EVC[NILNIL LSH -2] LOR EVCONE[NILNIL LAND '3];
      comment protect it from GC;
   END;

RECURSIVE PROCEDURE PRLIST(LIST LST);
   BEGIN

   RECURSIVE PROCEDURE CVLE(LIST LST);
      BEGIN
      WHILE LISTP(LST) DO
	 BEGIN
	 PRINT(" ");
	 PRLIST(CAR(LST));
	 LST←CDR(LST);
	 END;
      IF NULLP(LST) THEN PRINT(" )") ELSE PRINT(".",CVS(LST)," )");
      END;

   IF NULLP(LST) THEN PRINT("()") ELSE
   IF ATOMP(LST) THEN PRINT(LST)  ELSE
      BEGIN
      PRINT("(");
      CVLE(LST);
      END;
   END;

SIMPLE INTEGER PROCEDURE LENGTHI(LIST LS);
   BEGIN
   INTEGER LN;
   LN←0;
   WHILE LISTP(LS) DO
      BEGIN
      LN←LN+1;
      LS←CDR(LS);
      END;
   RETURN(LN);
   END;

SIMPLE LIST PROCEDURE REVERSE(LIST L,TAIL(NIL));
   BEGIN
   LIST ANS;
   ANS←NIL;
   SETQ(ANS,L);
   L←NIL; SETQ(L,TAIL);
   WHILE ANS>NIL DO
      BEGIN
      SETQ(L,CONS(CAR(ANS),L));
      SETQ(ANS,CDR(ANS));
      END;
   SETQ(ANS,NIL);
   DISSET(L);
   RETURN(L);
   END;

SIMPLE LIST PROCEDURE APPEND(LIST L1,L2);
   BEGIN
   LIST ANS;
   ANS←NIL;
   SETQ(ANS,REVERSE(L1));
   L1←NIL; SETQ(L1,L2);
   WHILE ANS>NIL DO
      BEGIN
      SETQ(L1,CONS(CAR(ANS),L1));
      SETQ(ANS,CDR(ANS));
      END;
   SETQ(ANS,NIL);
   DISSET(L1);
   RETURN(L1);
   END;

SIMPLE LIST PROCEDURE CADR(LIST L); RETURN(CAR(CDR(L)));
SIMPLE LIST PROCEDURE CDDR(LIST L); RETURN(CDR(CDR(L)));
SIMPLE LIST PROCEDURE CDAR(LIST L); RETURN(CDR(CAR(L)));
SIMPLE LIST PROCEDURE CAAR(LIST L); RETURN(CAR(CAR(L)));
SIMPLE LIST PROCEDURE CADDR(LIST L); RETURN(CAR(CDR(CDR(L))));
SIMPLE LIST PROCEDURE CADDDR(LIST L); RETURN(CAR(CDR(CDR(CDR(L)))));